
(*
* Bayes learner mapping code
* - insert
* - delete
* - lookup
*)



open ExtList
open Map
open Printf

open Constants
open Avlmap ;;

module Float = struct
  type t = float
  let compare = compare
end

module Int = struct
  type t = int
  let compare = compare
end

module EntryMap = Avlmap.Make (Float);;
module IntMap = Avlmap.Make (Int);;



type contract_state
    = {
    (* contract *)
    (* cs_contract : contract; *)
    (* final performance score *) 
    cs_state : float list; 
  }

type bmap = {
    k : int; 
    mapsize : int;
    thresh : float;
    gt_thresh : int;    
    entries : contract_state IntMap.t; (* one entry for each item *)
    emaps : (int EntryMap.t) list; (* size = k *)
  }

let cs_final = 3 (* drop first 3 *)

let cs_accrej = 0
let cs_score = 1
let cs_reg_control = 2 (* 0,1 *)
(* current bank status *)
let cs_equity_ratio = 3
let cs_liquidity_ratio = 4
let cs_cash_rate = 5
let cs_rate = 6
(* bs gap analysis *)
let cs_maturity = 7
let cs_principal = 8
let cs_gap_6month = 9
let cs_gap_1year = 10
let cs_gap_3year = 11
let cs_gap_10year = 12

let cs_max = 13

let empty_contract_state = { cs_state = List.make cs_max 0.0 }

let new_contract_state _ _ = empty_contract_state

(*
let bm_lookup bmap lparms itemid n =
  let k = lparms.k in
  *)

(*
let estimate bm k ixout vout ixin condition =
  let lkup = find_condition bm.entrymaps[ixout] k (condition ixin) vout
  in (mean (map (index ixout) lkup)) (* straight kmeans for now *)
*)

let add item bm =
  let mapper mp fl = EntryMap.add fl bm.mapsize mp in
  let prof = (List.nth item.cs_state cs_score) in
   { bm with
     emaps = List.map2 mapper bm.emaps item.cs_state ;
     entries = IntMap.add bm.mapsize item bm.entries ;
     gt_thresh = if ((prof:float) > (bm.thresh:float)) 
               then bm.gt_thresh + 1 else bm.gt_thresh;
     mapsize = bm.mapsize + 1 }

let empty kt thresh =
  { k = kt;
    mapsize = 0;
    gt_thresh = 0;
    thresh = thresh;
    entries = IntMap.empty;
    emaps = List.make kt EntryMap.empty  }

(* fuggly and inefficient for now *)
let bmap_map (func :( contract_state -> contract_state)) bm =
  let nentries = IntMap.map (func) bm.entries in
  let nemaps = List.make bm.k EntryMap.empty in
  let uf key bmentry emaps = 
    let mapper mp fl = EntryMap.add fl key mp in
    List.map2 mapper emaps bmentry.cs_state 
  in
  let fnemaps = IntMap.fold uf nentries nemaps in
  { bm with
    entries = nentries;
    emaps = fnemaps }

let bmap_print n bm =
  let printer (k,cs) =
    (sprintf " %6d %6d " n k)^
    (String.concat "" (List.map (sprintf " %6.4f ") cs.cs_state))
  in
  (String.concat "\n" (List.map printer (IntMap.as_list bm.entries))) ^ "\n"


(* merge uses the threshold from map 1 ... *)

(* *VERY* fuggly and inefficient for now *)
let merge m1 m2 =
  let lres = (List.map snd (IntMap.as_list m2.entries)) in
  List.fold_left ((fun mp ele -> add ele mp) : bmap -> contract_state  -> bmap)
    ( m1 : bmap) lres
    

let length bm = bm.mapsize

let dump bm = 
  let elist = (IntMap.as_list bm.entries) in
  List.fold_left (fun str ele -> str ^ (Std.dump ele) ^"\n") "" elist

(*
* 

bm_lookup :: bmap -> lookupparams -> itemid -> n -> prob

this estimates P(itemid=innum)

standard gaussian kernel for now

{1 \over \sqrt{2\pi} }\,e^{-\frac{(x-x_i)^2}{2 h^2}}

*)

let pi = 3.14159

let plcalc la (n0:float) (np:float) = exp ((-0.5 ) *. ((n0 -. np) /. la) ** 2.0)

let parzen_lookup bm itemid innum (n:int) lambda =
  let emap = List.nth bm.emaps itemid in
  let elist = List.map fst (EntryMap.find_segment n innum emap) in
  let sum = List.fold_left (+.) 0. in
  let nf = List.length elist in
  let sss = sum (List.map (plcalc lambda innum) (elist:float list)) in
  if nf == 0
  then 0.5
  else (1. /. ((float_of_int nf) *. lambda)) *. (1. /. (sqrt (2. *. pi))) *. sss


let parzen_lookup_cond bm itemid innum cond (n:int) lambda =
  let emap = List.nth bm.emaps itemid in
  let elist = List.map fst (EntryMap.find_condition n cond innum emap) in
  let sum = List.fold_left (+.) 0. in
  let nf = List.length elist in
  let sss = sum (List.map (plcalc lambda innum) (elist:float list)) in
  if nf == 0
  then 0.5
  else (1. /. ((float_of_int nf) *. lambda)) *. (1. /. (sqrt (2. *. pi))) *. sss

(*

P(prof > n | itemid = x) = P(prof > n ) --NUMPROD1-- . P(itemid = x | prof > n) --NUMPROD2-- / 
                           P(itemid = x) --DENOMPROD--

* accept

*)

let hiprof bm (itemid:int) (x:float) =
  let denomprod = parzen_lookup bm itemid x n lambda in
  let (nn,nd) = (float_of_int bm.gt_thresh,float_of_int bm.mapsize) in
  (* let numprod1 = nn /. (nd +. 1.) in *)
  let lkupcond csix = 
    (let cst = IntMap.find csix bm.entries in
     let sc = (List.nth cst.cs_state cs_score) in
     (* printf "sc is %f proft is %f\n" sc proft; *)
     (sc:float) > (bm.thresh:float) )
    in
  let numprod2 =  parzen_lookup_cond bm itemid x lkupcond n lambda in
  let ret = (if (bm.mapsize == 1) 
            then ( 0.5 )
            else (if ((abs_float denomprod) < 0.00000001)
                  then 0.5
                  else (numprod2) /. denomprod)) in
  (* printf "itemid %4d x %f np2 is %10.8f denomprod is %10.8f " itemid x numprod2 denomprod;
  printf "nn is %10.8f nd is %10.8f result %f " nd 1.0 (( numprod2) /. denomprod);
  printf "RET is %f\n%!" ret; *)
  ret
  
